PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/pascal/heap55.com/HEAPLOG.PAS

Pascal/Delphi Source File | 1990-01-07 | 7.6 KB | 312 lines

{*****************************************************************************
 This unit logs heap activity to disk. A report is automatically generated at
 program startup and exit. Additional reports may be generated at any time by
 calling DumpHeapLog.

 For further information, refer to HEAP.DOC.

 Copyright (C) TurboPower Software, 1989. All rights reserved.
 May be distributed freely, but not commercially without express permission
 of TurboPower Software.

 Version 5.0.
   First release.
 Version 5.5, 1/6/90
   Modified to work with TP 5.5.
*****************************************************************************}

{Define the following to have HEAPLOG report the FAR return address of each
 caller to GetMem and FreeMem}
{.$DEFINE AllocRet}

{$R-,S-,B-,F-,I-,V-}

unit HeapLog;
  {-Keep a log of heap activity}

interface

uses
  GrabHeap;

const
  MaxLog = 1000;              {Maximum number of blocks allocated at once}
  HeapLogName = 'HEAP.LOG';   {File name where log is written}

type
  LogRec =
    record
      PtrVal : Pointer;       {Address of heap block}
      AllocSize : Word;       {Bytes allocated}
      AllocAt0 : Pointer;     {First return address of GetMem or New call}
      {$IFDEF AllocRet}
      AllocAt1 : Pointer;     {Next return address of GetMem or New call}
      {$ENDIF}
    end;
  LogArray = array[1..MaxLog] of LogRec;

var
  Log : ^LogArray;            {Log array stored on heap}
  LogFilled : Boolean;        {Set true if simultaneous pointers exceed MaxLog}

function GetLog(Size : Word) : Pointer;
  {-GetMem with logging}

procedure FreeLog(P : Pointer; Size : Word);
  {-FreeMem with logging}

procedure DumpHeapLog(Msg : string);
  {-Write the current heap log to a file}

procedure ClearLog;
  {-Clear all entries from the log}

  {=================================================================}

implementation

const
  Digits : array[0..$F] of Char = '0123456789ABCDEF';
type
  SO =
    record
      O, S : Word;
    end;
  FreeRec =
    record
      OrgPtr : Pointer;
      EndPtr : Pointer;
    end;
  FreeList = array[0..8190] of FreeRec;
  FreeListP = ^FreeList;

var
  SaveExit : Pointer;

  function GetLog(Size : Word) : Pointer;
    {-GetMem with logging}
  type
    StackRec =
      record
        DummyIndex : Word;
        DummyP : Pointer;
        DummyFunc : Pointer;
        BP : Word;
        RetAddr : Pointer;
      end;
  var
    P : Pointer;
    Index : Word;
    Stack0 : StackRec absolute Index;
  begin
    {Let SYSTEM do the allocation}
    SystemHeapControl;
    GetMem(P, Size);
    GetLog := P;

    CustomHeapControl(GetLog, FreeLog);

    {Find next free log record}
    for Index := 1 to MaxLog do
      with Log^[Index] do
        if PtrVal = nil then begin
          {Unused log entry}
          PtrVal := P;
          AllocSize := Size;
          AllocAt0 := Stack0.RetAddr;

          {$IFDEF AllocRet}
          if Stack0.BP <> 0 then
            {AllocAt1 ASSUMES FIRST CALL WAS FAR!}
            AllocAt1 := StackRec(Ptr(SSeg, Stack0.BP-2)^).RetAddr
          else
            AllocAt1 := nil;
          {$ENDIF}

          Exit;
        end;

    {Else log table full}
    LogFilled := True;
  end;

  procedure FreeLog(P : Pointer; Size : Word);
    {-FreeMem with logging}
  var
    Index : Word;
  begin
    {Let SYSTEM do the deallocation}
    SystemHeapControl;
    FreeMem(P, Size);
    CustomHeapControl(GetLog, FreeLog);

    {Find and free the log record}
    for Index := 1 to MaxLog do
      with Log^[Index] do
        if PtrVal = P then begin
          PtrVal := nil;
          Exit;
        end;
  end;

  function HexW(W : Word) : string;
    {-Return hex string for word}
  begin
    HexW[0] := #4;
    HexW[1] := Digits[hi(W) shr 4];
    HexW[2] := Digits[hi(W) and $F];
    HexW[3] := Digits[lo(W) shr 4];
    HexW[4] := Digits[lo(W) and $F];
  end;

  function HexPtr(P : Pointer) : string;
    {-Return hex string for pointer}
  begin
    HexPtr := HexW(SO(P).S)+':'+HexW(SO(P).O);
  end;

  function FreeCount : Word;
    {-Return the number of free list elements}
  begin
    if SO(FreePtr).O = 0 then
      FreeCount := 0
    else
      FreeCount := ($10000-SO(FreePtr).O) shr 3;
  end;

  function PtrDiff(H, L : Pointer) : LongInt;
    {-Return the number of bytes between H^ and L^. H is the higher address}
  begin
    PtrDiff := ((LongInt(SO(H).S) shl 4+SO(H).O)-
                (LongInt(SO(L).S) shl 4+SO(L).O));
  end;

  procedure DumpHeapLog(Msg : string);
    {-Write the current heap log to a file}
  var
    Index : Word;
    Count : Word;
    FreeCnt : Word;
    FP : FreeListP;
    P0 : Pointer;
    P1 : Pointer;
    F : Text;
  begin
    Assign(F, HeapLogName);
    Reset(F);
    if IoResult = 0 then
      {File already exists}
      Append(F)
    else
      {New file}
      Rewrite(F);
    if IoResult <> 0 then
      Exit;

    {Count the number of heap blocks allocated}
    Count := 0;
    for Index := 1 to MaxLog do
      with Log^[Index] do
        if PtrVal <> nil then
          Inc(Count);
    FreeCnt := FreeCount;

    {Write a message at the start of this dump}
    WriteLn(F);
    WriteLn(F, Msg);
    WriteLn(F);
    WriteLn(F, 'MemAvail: ', MemAvail);
    WriteLn(F, 'MaxAvail: ', MaxAvail);
    WriteLn(F, 'HeapPtr : ', HexPtr(HeapPtr));
    WriteLn(F, 'HeapCnt : ', Count);
    WriteLn(F, 'FreeCnt : ', FreeCnt);
    WriteLn(F, 'Filled  : ', LogFilled);

    if Count <> 0 then begin
      WriteLn(F);
      WriteLn(F, '  Pointer   Size  Allocated at');
      {           ssss:oooo  xxxxx  ssss:oooo  ssss:oooo}
      for Index := 1 to MaxLog do
        with Log^[Index] do
          if PtrVal <> nil then begin
            {Convert code addresses to relative format}
            P0 := AllocAt0;
            if P0 <> nil then
              Dec(SO(P0).S, PrefixSeg+$10);
            {$IFDEF AllocRet}
            P1 := AllocAt1;
            if P1 <> nil then
              Dec(SO(P1).S, PrefixSeg+$10);
            {$ENDIF}
            WriteLn(F, HexPtr(PtrVal), '  ', AllocSize:5, '  ', HexPtr(P0)
                    {$IFDEF AllocRet}
                    ,'  ', HexPtr(P1)
                    {$ENDIF}
                    );
          end;
    end;

    if FreeCnt <> 0 then begin
      {Write out the free list}
      FP := FreePtr;
      WriteLn(F);
      WriteLn(F, 'Free start  Size');
      {           ssss:oooo nnnnnn}
      for Index := 0 to FreeCnt-1 do
        with FP^[Index] do
          WriteLn(F, HexPtr(OrgPtr), ' ', PtrDiff(EndPtr, OrgPtr):6);
    end;

    Index := IoResult;
    Close(F);
    Index := IoResult;
  end;

  procedure ClearLog;
    {-Clear all entries from the log}
  begin
    LogFilled := False;
    FillChar(Log^, SizeOf(LogArray), 0);
  end;

  {$F+}
  procedure ExitP;
    {-Write the final log report}
  begin
    ExitProc := SaveExit;
    DumpHeapLog('Final');
  end;
  {$F-}

  procedure DelLogFile;
    {-Delete existing log file, if any}
  var
    I : Word;
    F : file;
  begin
    Assign(F, HeapLogName);
    Erase(F);
    I := IoResult;
  end;

begin
  {Delete previous log file, if any}
  DelLogFile;

  {Allocate the log array on the heap}
  GetMem(Log, SizeOf(LogArray));

  {Clear out the log array}
  ClearLog;

  {Take over heap allocation control}
  CustomHeapControl(GetLog, FreeLog);

  {Set up to dump a final report}
  SaveExit := ExitProc;
  ExitProc := @ExitP;

  {Dump initial report}
  DumpHeapLog('Initial');
end.